home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
TPUG - Toronto PET Users Group
/
TPUG Users Group CD
/
TPUG Users Group CD.iso
/
COMAL
/
B-Book Series
/
(k)b9.d64
/
src.example
< prev
next >
Wrap
Text File
|
2007-02-28
|
7KB
|
401 lines
;
;EXAMPLE PACKAGES FOR COMAL 2.0
;
;BY JESSE KNIGHT
;
;ADD + STRING$ FROM UNICOMAL (WITH CHANGES)
;
; 1/29/85
;
.LIB C64SYMB
.OPT LIST
;
*=$8009
;
;
;
.BYT DEFPAG ;MEMORY MAP
.WOR END ;END OF PACKAGE
.WOR SENSE ;SENSE ROUTINE
;
;TABLE OF PACKAGES
;
.BYT 4,'DEMO' ;NAME IS DEMO
.WOR DEMOP ;DEMO PROCEDURE TABLE
.WOR DEMOI ;DEMO INIT ROUTINE
;
.BYT 6,'LOCATE' ;NAME IS LOCATE
.WOR LOCP ;LOCATE PROCEDURE TABLE
.WOR LOCI ;LOCATE INIT ROUTINE
;
.BYT 0 ;END OF TABLE
;
;SET BORDER COLOR TO FLAG
;SENT TO SENSE ROUTINE
;FOR VISIBLE EFFECT
;
SENSE STY BORCOL
RTS
;
;FLASH BORDER COLOR
;IN DEMO INIT ROUTINE FOR
;VISIBLE EFFECT
;
DEMOI LDX #16 ;16 TIMES
LDY #0 ;256 TIMES
FLASH INC BORCOL
DEX
BNE FLASH
DEY
BNE FLASH
RTS
;
;PROCEDURE TABLE FOR DEMO
;
DEMOP .BYT 3,'ADD' ;FUNCTION ADD
.WOR FADD ;DESCRIPTOR POINTER
.BYT 6,'STRING' ;FUNCTION STRING
.WOR FSTRNG
.BYT 12,'CONVERT''CASE' ;PROC CONVERT'CASE
.WOR PCASE
.BYT 0 ;END OF TABLE
;
;FUNC ADD#(A#,B#)
;
FADD .BYT FUNC+INT ;INTEGER FUNC
.WOR ADD ;POINT TO CODE
.BYT 2 ;2 PARAMETERS
.BYT PARAM+INT,PARAM+INT ;BOTH INTEGER
.BYT ENDFNC ;END FUNC
;
;FUNC STRING$(A$,N)
;
FSTRNG .BYT FUNC+STR ;STRING FUNC
.WOR STRING ;POINT TO CODE
.BYT 2 ;2 PARAMETERS
.BYT PARAM+STR ;FIRST IS STRING
.BYT PARAM+INT ;SECOND IS INTEGER
.BYT ENDFNC ;END FUNC
;
;PROC CONVERT'CASE(REF A$,B)
;
PCASE .BYT PROC ;PROCEDURE
.WOR CVCASE ;POINT TO CODE
.BYT 2 ;2 PARAMETERS
.BYT REF+STR ;FIRST IS REF STRING
.BYT PARAM+INT ;SECOND IS INTEGER
.BYT ENDPRC ;END PROC
;
;
;FUNC ADD#(A#,B#)
; RETURN A#+B#
;ENDFUNC ADD#
;
ADD LDA #1
JSR FNDPAR ;FIND PARAM 1
;
LDX COPY1 ;MOVE COPY1 TO COPY2
STX COPY2
LDX COPY1+1
STX COPY2+1
;
LDA #2
JSR FNDPAR ;FIND PARAM 2
;
LDY #1 ;GET READY TO ADD
CLC
LDA (COPY1),Y ;ADD LO BYTES
ADC (COPY2),Y
TAX ;SAVE IN .X
DEY
LDA (COPY1),Y ;ADD HI BYTES
ADC (COPY2),Y
BVS OVRERR ;OVERFLOW ERROR
;
JMP PSHINT ; INT IN .A/.X TO REAL, PUSH, AND RETURN
;
OVRERR LDX #2 ; REPORT "OVERFLOW"
JMP RUNERR
;
;FUNC STRING$(A$,N#)
; IF N#<0 THEN REPORT 1 //ARGUMENT ERROR
; IF LEN(A$)<>1 THEN REPORT 1,"STRING LENGTH ..."
; DIM R$ OF N#
; FOR X#=1 TO N# DO
; R$:+A$
; ENDFOR X#
; RETURN R$
;ENDFUNC STRING$
;
STRING LDA #2
JSR FNDPAR ;FIND PARAM 2
LDY #0
LDA (COPY1),Y ;HI BYTE
BMI ARGERR ;NEGATIVE
STA NUMBER+1 ;SAVE IT
INY
LDA (COPY1),Y ;LO BYTE
STA NUMBER ;SAVE IT
;
;MAKE ROOM FOR RESULT ON EVALUATION STACK
;REPORT "CANNOT ASSIGN VARIABLE" IF NO ROOM
;
CLC
ADC STOS ;TOP OF STACK
TAX ;SAVE IN .X
LDA NUMBER+1 ;HI BYTE
ADC STOS+1
BCS STERR ;OUT OF MEMORY ERROR
TAY ;SAVE IN .X
TXA
ADC #2 ;2 BYTES FOR LENGTH
TAX
TYA
ADC #0 ;ADD CARRY
BCS STERR ;ERROR
;
CPX SFREE ;TEST IF ROOM
SBC SFREE+1
BCS STERR ;NOT ENOUGH ROOM
;
;TEST A$
;
LDA #1
JSR FNDPAR ;FIND IT
LDY #2 ;TEST CURRENT LENGTH
LDA (COPY1),Y ;HI BYTE
BNE LNGERR ;>=256 - LONG STRING ERROR
INY
LDA (COPY1),Y ;LO BYTE
CMP #1
BNE LNGERR ;NOT =1 -LONG STRING ERROR
;
INY ;.Y=4
LDA (COPY1),Y ;CONTENTS OF A$
LDY #0
STY Q1 ;Q1=0
STY Q1+1
;
STR1 LDX NUMBER+1 ;TEST FOR END OF LOOP
CPX Q1+1
BNE STR2 ;NOT YET
LDX NUMBER
CPX Q1
BEQ STR4 ;END OF LOOP
;
STR2 STA (STOS),Y ;PUT ON STACK
INC STOS ;INC POINTER
BNE STR3
INC STOS+1
;
STR3 INC Q1
BNE STR1 ;MORE TO DO
INC Q1+1
BNE STR1 ;(JMP)
;
STR4 LDA NUMBER+1 ;PUT LENGTH ON STACK
STA (STOS),Y ;HI BYTE
INY
LDA NUMBER
STA (STOS),Y
;
CLC ;STOS:+2 FOR LENGTH
LDA STOS
ADC #2
STA STOS
BCC STR5
INC STOS+1
STR5 RTS ;IT'S DONE
;
ARGERR LDX #1 ;ARGUMENT ERROR
.BYT $2C ;SKIP 2
STERR LDX #56 ;CANNOT ASSIGN VARIABLE
JMP RUNERR
;
;SPECIAL ERROR REPORTER FOR STRING$
;
;REPORTS ERROR NUMBER 1 FOR ARGUMENT ERROR
;BUT GIVES MORE SPECIFIC MESSAGE
;"STRING LENGTH OF 1 EXPECTED"
;
;ERRFILE IS SET TO 0 SINCE ERROR NOT FROM FILE
;
;ERROR NUMBER MUST BE IN RANGE 0 .. 65535
;
;TEXT FOR ERROR MUST BE <80 CHARACTERS
;
LNGERR LDY #TXTLEN ;LENGTH OF TEXT
STY ERTLEN ;SET LENGTH FOR SYSTEM
XFRTXT LDA ERRMSG-1,Y ;MOVE TEXT TO ERTEXT
STA ERTEXT-1,Y
DEY
BNE XFRTXT
;
LDA #$6C ;STORE JMP (TRAPVC) IN AC1
LDX #<TRAPVC
LDY #>TRAPVC
STA AC1
STX AC1+1
STY AC1+2
;
LDY #0 ;ERRFILE = 0
LDX #1 ;LO BYTE OF ERR #
LDA #0 ;HI BYTE OF ERR #
;
;NOW EXECUTE JMP (TRAPCV) IN PAGE B
;
JSR GOTO ;USING GOTO
.BYT PAGEB ;PAGE B
.WOR AC1 ;JMP (TRAPVC) AT AC1
;
;TEXT FOR ERROR MESSAGE
;
ERRMSG .BYT 'STRING LENGTH OF 1 EXPECTED'
TXTLEN =*-ERRMSG
;
;
;PROC CONVERT'CASE (REF A$,B)
; IF B<0 OR B>1 THEN REPORT 2 //ARGUMENT ERROR
; IF LEN(A$)>0 THEN // NOT NULL STRING
; IF B=0 THEN //LOWER TO UPPER
; C=65 //LOWER BOUND
; D=91 //UPPER BOUND
; ENDIF
;
; IF B=1 THEN //UPPER TO LOWER
; C=193 //LOWER BOUND
; D=219 //UPPER BOUND
; ENDIF
;
; FOR X=1 TO LEN(A$)
; IF ORD(A$(X))>=C AND ORD(A$(X))<D THEN //WRAP LINE
; A$(X)=CHR$(ORD(A$(X))BITXOR($80)) //FLIP CASE
; ENDFOR X
; ENDIF
;
;ENDPROC CONVERT'CASE
;
CVCASE LDA #2 ;FIND B
JSR FNDPAR
LDY #0 ;TEST B
LDA (COPY1),Y ;HI BYTE
BMI ARGERR ;<0
INY
LDA (COPY1),Y ;LO BYTE
CMP #2
BCS ARGERR ;>1
;
CMP #1 ;WHICH WAY ?
BEQ LWER ;UPPER TO LOWER
;
LDA #65 ;SET BOUNDS FOR LOWER TO UPPER
STA LOWBND
LDA #91
STA UPRBND
BNE CVC ;(JMP)
;
LWER LDA #193 ;SET BOUNDS FOR UPPER TO LOWER
STA LOWBND
LDA #219
STA UPRBND
;
;
CVC LDA #1 ;FIND A$
JSR FNDPAR
LDY #2 ;GET LENGTH
LDA (COPY1),Y ;HI BYTE
TAX ;SAVE IN .X
INY
LDA (COPY1),Y ;LO BYTE
STA INF1 ;SAVE IN INF1
;
BNE NTNULL ; LO>0
TXA
BNE NTNULL ; LO AND HI =0
RTS ;NULL STRING NO ACTION
;
NTNULL INY
CVC1 LDA (COPY1),Y ;BYTE OF STRING
CMP LOWBND ;TEST LOWER BOUND
BCC OUTBND ;< BOUND
CMP UPRBND ;TEST UPPER BOUND
BCS OUTBND ;>= BOUND
;
EOR #$80 ;TOGGLE CASE
STA (COPY1),Y ;STORE NEW VALUE
;
OUTBND DEC INF1 ;DEC LO COUNTER
BNE NTDNE ;NOT DONE YET
DEX ;DEC HI COUNTER
BPL NTDNE ;NOT DONE YET
RTS ;FINISHED
;
NTDNE INY ;NEXT CHAR
BNE CVC1 ;MORE TO DO
INC COPY1+1 ;BUMP HI
JMP CVC1
;
LOWBND .BYT 0 ;LOWER BOUND STORAGE
UPRBND .BYT 0 ;UPPER BOUND STORAGE
;
;PACKAGE: LOCATE
;
LOCI RTS ;NO INIT NEEDED FOR LOCATE
;
;PROCEDURE TABLE FOR LOCATE
;
LOCP .BYT 11,'LOCATE''REAL' ;FUNCTION LOCATE'REAL
.WOR FLOCRL ;DESCRIPTOR POINTER
.BYT 10,'LOCATE''INT' ;FUNCTION LOCATE'INT
.WOR FLOCIN
.BYT 10,'LOCATE''STR' ;FUNC LOCATE'STR
.WOR FLOCST
.BYT 0 ;END OF TABLE
;
;FUNC LOCATE'REAL (REF A)
;
FLOCRL .BYT FUNC+REAL ;REAL FUNC
.WOR LOCCOD ;POINT TO CODE
.BYT 1 ;1 PARAMETER
.BYT REF+REAL ;REFERENCE REAL
.BYT ENDFNC
;
;FUNC LOCATE'INT (REF A#)
;
FLOCIN .BYT FUNC+REAL ;REAL FUNC
.WOR LOCCOD ;POINT TO CODE
.BYT 1 ;1 PARAMETER
.BYT REF+INT ;REFERENCE INTEGER
.BYT ENDFNC
;
;FUNC LOCATE'STR (REF A$)
;
FLOCST .BYT FUNC+REAL ;REAL FUNC
.WOR LOCCOD ;POINT TO CODE
.BYT 1 ;1 PARAMETER
.BYT REF+STR ;REFERENCE STRING
.BYT ENDFNC
;
;ALL FUNCTIONS IN LOCATE ARE
;TO RETURN THE ADDRESS OF THE VARIABLE
;PASSED AS THE PARAMETER.
;
;DIFFERENT FUNCTIONS ARE NEEDED
;FOR EACH VARIABLE TYPE BECAUSE
;OF THE PARAMETER TYPE TESTS
;PERFORMED BY COMAL.
;
;SEPERATE CODE IS NOT NEEDED TO
;RETURN THE ADDRESS SINCE FINDING
;THE PARAMETER AND RETURNING ITS
;ADDRESS IS THE SAME FOR ALL TYPES.
;
LOCCOD LDA #1 ;FIRST PARAM
JSR FNDPAR ;FIND IT
LDX COPY1+1 ;HI BYTE IN .X
LDA COPY1 ;LO BYTE IN .A
JMP INTFPA ;FLOAT AND PUSH UNSIGNED INTEGER
;
;
END .END